/* -*- Mode: C -*- */

#define PERL_NO_GET_CONTEXT 1

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#include <string.h>
#include <stdio.h>
#include <sys/file.h>
#include <sys/types.h>
#include <unistd.h>

static FILE *out = 0;
static char *outname;

static HV *file_id_hv;
static SV *granularity_sv;

#if defined (HAS_GETTIMEOD)
static struct timeval old_time;
#else
static UV old_time[2];
static int (*u2time)(pTHX_ UV *) = 0;
#endif

static struct tms old_tms;
static int usecputime = 1;
static int canfork = 0;

static char *old_fn = "";
static IV old_line = 0;
static int trace;

/* dummy CXt_foo values for the file and line of the statement being executed */
#define FPt_FILE    16
#define FPt_LINE    17

#define putmark(mark) putc(-(mark), out)
#define putpvn(str, len) { putiv(aTHX_ (len)); fwrite((str), 1, (len), out); }
#define putpv(str) { STRLEN len = strlen((str)); putpvn((str), len); }
#define put0() putc(0, (out))

#if !defined(OutCopFILE)
#define OutCopFILE CopFILE
#endif

/* some kind of huffman encoding for numbers */

static void
_putiv(pTHX_ U32 n) {
    n-=128;
    if (n < 16384) {
        putc((n>>8) | 0x80, out);
        putc(n & 0xff, out);
    }
    else {
        n -= 16384;
        if (n < 2097152) {
            putc((n>>16) | 0xc0, out);
            putc((n>>8) & 0xff, out);
            putc(n & 0xff, out);
        }
        else {
            n -= 2097152;
            if (n < 268435456) {
                putc((n>>24) | 0xe0, out);
                putc((n>>16) & 0xff, out);
                putc((n>>8) & 0xff, out);
                putc(n & 0xff, out);
            }
            else {
                n -= 268435456;
                putc(0xf0, out);
                putc((n>>24), out);
                putc((n>>16) & 0xff, out);
                putc((n>>8) & 0xff, out);
                putc(n & 0xff, out);
            }
        }
    }
}

static void
putiv(pTHX_ I32 i32) {
    U32 n = (U32)i32;
    if (n < 128)
        putc(n, out);
    else 
        _putiv(aTHX_ n);
}

static void
putav(pTHX_ AV *av) {
    UV nl = av_len(av)+1;
    UV i;
    putiv(aTHX_ nl);
    for (i=0; i<nl; i++) {
        SV **psv = av_fetch(av, i, 0);
        if (psv) {
            STRLEN ll;
            char *data = SvPV(*psv, ll);
            putpvn(data, ll);
        }
        else {
            put0();
        }
    }
}

static IV
fgetiv(pTHX_ FILE *in) {
    int c0 = getc(in);
    if (c0 < 128) {
	if (c0 < 0) croak ("unexpected end of file");
	return c0;
    }
    else {
	int c1 = getc(in);
	if (c0 < 192) {
	    return 128 + c1 + ((c0 & 0x3f) << 8);
	}
	else {
	    int c2 = getc(in);
	    if (c0 < 224) {
		return (128 + 16384) + c2 + ((c1 + ((c0 & 0x1f) << 8)) << 8);
	    }
	    else {
		int c3 = getc(in);
		if (c0 < 240) {
		    return (128 + 16384 + 2097152) + c3 + ((c2 + ((c1 + ((c0 & 0x0f) << 8)) << 8)) << 8);
		}
		else {
		    int c4 = getc(in);
		    if (c0 == 240) {
			return (128 + 16384 + 2097152 + 268435456) + c4 + ((c3 + ((c2 + (c1 << 8)) << 8)) << 8);
		    }
		    else {
			Perl_croak(aTHX_ "bad file format");
		    }
		}
	    }
	}
    }
}

static char
fgetmark(pTHX_ FILE *in) {
    int c = getc(in);
    if (c < 240) {
	ungetc(c, in);
	return 0;
    }
    return ((-c) & 0x0f);
}


static SV *
_fgetpvn(pTHX_ FILE *in, IV len) {
    if (len) {
	SV *sv = newSV(len);
	char *buffer = SvPVX(sv);
	int count = fread(buffer, 1, len, in);
	if (count < len) {
	    SvREFCNT_dec(sv);
	    Perl_croak(aTHX_ "unexpected end of file");
	}
	buffer[len] = '\0';
	SvPOK_on(sv);
	SvCUR_set(sv, len);
	return sv;
    }
    return newSVpvn("", 0);
}

static SV *
fgetpv(pTHX_ FILE *in) {
    return _fgetpvn(aTHX_ in, fgetiv(aTHX_ in));
}

static AV*
fgetav(pTHX_ FILE *in) {
    AV *av = newAV();
    IV lines = fgetiv(aTHX_ in);
    IV i;
    for (i=0; i<lines; i++) {
	SV *sv = fgetpv(aTHX_ in);
	av_store(av, i, sv);
    }
    return av;
}

static int
fneof(FILE *in) {
    int c = getc(in);
    if (c != EOF) {
	ungetc(c, in);
	return 1;
    }
    return 0;
}

static AV *
get_file_src(pTHX_ char *fn) {
    char *avname;
    AV *lines;
    SV *src = newSVpv("main::_<", 8);

    sv_catpv(src, fn);
    avname = SvPV_nolen(src);
    lines = get_av(avname, 0);
    SvREFCNT_dec(src);
    return lines;
}

static UV
get_file_id(pTHX_ char *fn) {
    static IV file_id_generator = 0;
    SV ** pe;
    UV id;
    STRLEN fnl = strlen(fn);

    pe = hv_fetch(file_id_hv, fn, fnl, TRUE);
    if (SvOK(*pe))
	return SvUV(*pe);

    ++file_id_generator;
	
    putmark(1);
    putiv(aTHX_ file_id_generator);
    putpvn(fn, fnl);
	
    sv_setiv(*pe, file_id_generator);

    if ((fn[0] == '(' && (strncmp("eval", fn+1, 4)==0 || 
			  strncmp("re_eval", fn+1, 7)==0 ) ) ||
	(fn[0] == '-' && fn[1] == 'e' && fn[2] == '\0')) {

	AV *lines = get_file_src(aTHX_ fn);
	if (lines) {
	    putmark(2);
	    putiv(aTHX_ file_id_generator);
	    putav(aTHX_ lines);
	}
    }
    return file_id_generator;
}

static IV
mapid(pTHX_ HV *fpidmap, IV pid, IV fid) {
    static IV lfpid = 0;
    static SV *key = 0;
    SV **ent;
    char *k;
    STRLEN l;
    if (!key) key = newSV(30);
    sv_setpvf(key, "%d:%d", pid, fid);
    k = SvPV(key, l);
    ent = hv_fetch(fpidmap, k, l, TRUE);
    if (!SvOK(*ent))
	sv_setiv(*ent, ++lfpid);
    return SvIV(*ent);
}

static void
flock_and_header(pTHX) {
    static IV lpid = 0;
    IV pid = getpid();
    if (pid != lpid && lpid) {
	out = fopen(outname, "ab");
	if (!out)
	    Perl_croak(aTHX_ "unable to reopen file %s", outname);

	flock(fileno(out), LOCK_EX);
	fseek(out, 0, SEEK_END);

	putmark(5);
	putiv(aTHX_ pid);

	putmark(6);
	putiv(aTHX_ lpid);

    }
    else {
	flock(fileno(out), LOCK_EX);
	fseek(out, 0, SEEK_END);

	putmark(5);
	putiv(aTHX_ pid);
    }
    lpid = pid;
}


#ifndef DEBUGGING
static char* PL_block_type[] = {
    "NULL",
    "SUB",
    "EVAL",
    "LOOP",
    "SUBST",
    "BLOCK",
};
#endif

/* based on S_dopoptosub_at() from perl pp_ctl.c */
static int
dopopcx_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock, UV stop_at)
{
    I32 i;
    register PERL_CONTEXT *cx;
    for (i = startingblock; i >= 0; i--) {
        cx = &cxstk[i];
	UV type_bit = 1 << CxTYPE(cx);
	if (type_bit & stop_at)
	    return i;
    }         
    return i;   
}

static COP *
start_cop_of_context(pTHX_ PERL_CONTEXT *cx) {
    OP *o = NULL;
    int type;
    if (trace)
        warn("start_cop_of_context: looking for start of %s\n", PL_block_type[CxTYPE(cx)]);
    switch (CxTYPE(cx)) {
    case CXt_EVAL:    
        o = (OP*)cx->blk_oldcop;
        break;
    case CXt_FORMAT:
        o = CvSTART(cx->blk_sub.cv);
        break;
    case CXt_SUB: 
        o = CvSTART(cx->blk_sub.cv);
        break;
    case CXt_LOOP:
        /* blk_loop.next_op takes us closer to the origin of the loop
         * but it's not a cop (OP_NEXTSTATE, OP_SETSTATE, OP_DBSTATE)
         * so doesn't have a line number */
        o = cx->blk_loop.redo_op;
        break;
    case CXt_BLOCK:
        o = (OP*)cx->blk_oldcop;
        break;
    case CXt_SUBST:
        o = NULL;    /* XXX */
        break;
    }
    if (!o) {
	if (trace)
	    warn("start_cop_of_context: can't find start of %s\n", PL_block_type[CxTYPE(cx)]);
        return NULL;
    }
    if (trace) {
        warn("start_cop_of_context for %s is %s (op_type %d)\n",
            PL_block_type[CxTYPE(cx)], OP_NAME(o), o->op_type);
        if (trace >= 2)
            do_op_dump(1, PerlIO_stderr(), o);
    }
    /* find next cop from OP */
    while ( o && (type = (o->op_type) ? o->op_type : o->op_targ) ) {
        if (trace)
            warn("start_cop_of_context: op_type %d\n", type);
        if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
            return (COP*)o;
        /* should never get here? */
	if (trace)
	    warn("%s isn't a cop", OP_NAME(o));
        if (trace >= 2)
            do_op_dump(1, PerlIO_stderr(), o);
        o = o->op_next;
    }
    if (trace && type != 0)
        warn("start_cop_of_context: can't find next op for %s line %d\n",
            PL_block_type[CxTYPE(cx)], CopLINE(PL_curcop));
    return NULL;
}

static PERL_CONTEXT *
nearest_interesting_context(pTHX_ UV stop_at) {
    dSP;
    /* modelled on pp_caller() in pp_ctl.c */
    register I32 cxix = cxstack_ix;
    register PERL_CONTEXT *cx = NULL;
    register PERL_CONTEXT *ccstack = cxstack;
    PERL_SI *top_si = PL_curstackinfo;

    if (trace >= 2)
        warn("nearest_interesting_context: \n");

    for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
            if (trace)
                warn("not on main stack (type %d) so digging top_si %p->%p, ccstack %p->%p\n",
                top_si, top_si->si_prev, ccstack, top_si->si_cxstack);
            top_si  = top_si->si_prev;
            ccstack = top_si->si_cxstack;
            cxix = dopopcx_at(aTHX_ ccstack, top_si->si_cxix, stop_at);
        }
        if (cxix < 0) {
            if (trace)
                warn("cxix < 0\n");
            return NULL;
        }
        cx = &ccstack[cxix];
        if (trace) {
            warn("considering: %s %p %p %s\n",
                PL_block_type[CxTYPE(cx)], 0, 0, "");
            if (trace >= 2) {
                switch (CxTYPE(cx)) {
                case CXt_SUB: 
                    sv_dump((SV*)cx->blk_sub.cv);
                    break;
                }
            }
        }

        /* return this context, unless it's the debugger */
        if (!(PL_DBsub && CxTYPE(cx) == CXt_SUB
                    && CvSTASH(cx->blk_sub.cv) == PL_debstash
        )) {
            if (trace)
                warn("selected\n");
            return cx;
        }
        /* no joy, look further */
        if (trace)
            warn("looking further, ccstack %p, cxix %d\n", ccstack, cxix);
        cxix = dopopcx_at(aTHX_ ccstack, cxix - 1, stop_at);
    }
    return NULL; /* not reached */
}


MODULE = Devel::FastProf		PACKAGE = DB
PROTOTYPES: DISABLE

BOOT:
    trace = (getenv("PERL_FASTPROF_TRACE") ? atoi(getenv("PERL_FASTPROF_TRACE")) : 0);
    if (trace)
	warn("Devel::FastProf BOOT");



I32
constant()
    PROTOTYPE:
    ALIAS:
        CXt_NULL    = CXt_NULL
        CXt_EVAL    = CXt_EVAL
        CXt_SUB     = CXt_SUB
        CXt_FORMAT  = CXt_FORMAT
        CXt_LOOP    = CXt_LOOP
        CXt_BLOCK   = CXt_BLOCK
        CXt_SUBST   = CXt_SUBST
        FPt_FILE    = FPt_FILE
        FPt_LINE    = FPt_LINE
    CODE:
    RETVAL = ix;                         
    OUTPUT:
    RETVAL


void DB(...)
PPCODE:
    {
        IV ticks;
        if (usecputime) {
            struct tms buf;
            times(&buf);
            ticks = buf.tms_utime - old_tms.tms_utime + buf.tms_stime - old_tms.tms_stime;
        }
        else {
#if defined(HAS_GETTIMEOD)
            struct timeval time;
            gettimeofday(&time, NULL);
            if (time.tv_sec < old_time.tv_sec + 2000) {
                ticks = (time.tv_sec - old_time.tv_sec) * 1000000 + time.tv_usec - old_time.tv_usec;
            }
#else
            UV time[2];
            (*u2time)(aTHX_ time);
            if (time[0] < old_time[0] + 2000) {
                ticks = (time[0] - old_time[0]) * 1000000 + time[1] - old_time[1];
            }
#endif
            else {
                ticks = 2000000000;
            }
        }
        if (out) { /* out should never be NULL anyway */
            IV fid;
            IV line;
            char *file;
            UV granularity;
            PERL_CONTEXT *near_cx;
            if (canfork)
                flock_and_header(aTHX);
            COP *cop;
#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8))
            /*PERL_CONTEXT *cx = cxstack + cxstack_ix;*/
            cop = (cxstack + cxstack_ix)->blk_oldcop;;
#else
            cop = PL_curcop;
#endif
            granularity = SvUV(granularity_sv);
            if (trace) {
                if (trace >= 2)
                    warn("%s:%d\t0x%x\n", OutCopFILE(cop), CopLINE(cop), granularity);
                else
                    warn("%s:%d\n", OutCopFILE(cop), CopLINE(cop));
            }

            if (granularity & (1 << FPt_LINE)) {
                line = CopLINE(cop);
            }
            else if (granularity & (1 << FPt_FILE)) {
                line = 1;
            }
            else {
                near_cx = nearest_interesting_context(aTHX_ granularity);
                if (near_cx) {
                    COP *near_cop = start_cop_of_context(aTHX_ near_cx);
                    if (trace)
                        warn("nearest_interesting_context %p: cop %p->%p, line %d->%d (file %s)",
                            near_cx, cop, near_cop,
                            CopLINE(cop), CopLINE(near_cop),
                            (near_cop && CopFILE(near_cop) != old_fn) ? CopFILE(near_cop):"");
                    if (near_cop)
                        cop = near_cop;
                } /* else use default cop = current line */
                if (trace)
                    warn("----");
                line = CopLINE(cop);
            }
            file = OutCopFILE(cop);

            if (file != old_fn && strNE(file, old_fn)) {
                fid = get_file_id(aTHX_ file);
                putmark(7);
                putiv(aTHX_ fid);
                old_fn = file;
            }
            putiv(aTHX_ line);
            if (ticks < 0) ticks = 0;
            putiv(aTHX_ ticks);
            
            if (canfork) {
                fflush(out);
                flock(fileno(out), LOCK_UN);
            }
        }
        if (usecputime) {
            times(&old_tms);
        }
        else {
#if defined (HAS_GETTIMEOD)
            gettimeofday(&old_time, NULL);
#else
            (*u2time)(aTHX_ old_time);
#endif
        }
    }


void
sub__xs(...)
PPCODE:
    {
	/* Incomplete XS version of the sub__perl() in FastProf.pm */
	/* Currently just trying to be 'transparent' to prove it works	*/
	/* I couldn't get it to work with 5.8.6, which is what I needed	*/
	/* so I just worked with sub__perl instead */
        dXSARGS;
        dORIGMARK;
        SV *sub_sv = GvSV(PL_DBsub);
        HV *oldstash;
        warn("--> %s (%d items)", SvPV_nolen(sub_sv), items);
	sv_dump(sub_sv);
        if (items < 0) {
            warn("Negative item count (%d) in DB::sub for %s ignored", items, SvPV_nolen(sub_sv));
            items = 0;
        }
        SP -= items;
        PUSHMARK( ORIGMARK );
#ifdef G_NODEBUG
        perl_call_sv( (SvIV(sub_sv)) ? (SV*)SvIV(sub_sv) : sub_sv, GIMME | G_NODEBUG);
#else
        oldstash = curstash;
        curstash = debstash;    /* To disable debugging of perl_call_sv */
#ifdef PERLDBf_NONAME
        perl_call_sv( (SvIV(sub_sv)) ? (SV*)SvIV(sub_sv) : sub_sv, GIMME );
#else
        perl_call_sv( sub_sv, GIMME );
#endif 
        curstash = oldstash;
#endif 
        SPAGAIN;
        PUTBACK;
        warn("<--");
        return;
    }


void _finish(...)
PPCODE:
    if (out) {
        if (canfork) {
            flock_and_header(aTHX);
            fflush(out);
            flock(fileno(out), LOCK_UN);
        }
        fclose(out);
        out = NULL;
    }
    PL_perldb = 0; /* turn off debugging */


void _init(char *_outname, int _usecputime, int _canfork)
PPCODE:
    {
        out = fopen(_outname, "wb");
        if (!out)
	    Perl_croak(aTHX_ "Can't open file %s for writing: %s", _outname, strerror(errno));
        fwrite("D::FP-" XS_VERSION "\0\0\0\0\0\0\0", 1, 12, out);
        putmark(3);
        if (_usecputime) {
            usecputime = 1;
            putiv(aTHX_ sysconf(_SC_CLK_TCK));
            times(&old_tms);
        }
        else {
            putiv(aTHX_ 1000000);
            usecputime = 0;
#if defined (HAS_GETTIMEOD)
            gettimeofday(&old_time, NULL);
#else
            {
                SV **svp = hv_fetch(PL_modglobal, "Time::U2time", 12, 0);
                if (!svp || !SvIOK(*svp)) Perl_croak(aTHX_ "Time::HiRes is required");
                u2time = INT2PTR(int(*)(pTHX_ UV*), SvIV(*svp));
            }
            (*u2time)(aTHX_ old_time);
#endif
        }
        if (_canfork) {
            canfork = 1;
            outname = strdup(_outname);
        }
        file_id_hv = get_hv("DB::file_id", TRUE);
        granularity_sv = perl_get_sv("Devel::FastProf::granularity", GV_ADDWARN);
        if (!SvOK(granularity_sv)) {
            warn("defaulting $Devel::FastProf::granularity to FPt_LINE\n");
            sv_setuv(granularity_sv, 1<<FPt_LINE);
        }
        if (trace)
            warn("granularity_sv 0x%x\n", SvUV(granularity_sv));
    }

void
enable_profile(...)
    PPCODE:
	IV prev_DBsingle = SvIV(PL_DBsingle);
	warn("enable_profile (was %d, perldb %x) in pid %d", prev_DBsingle, PL_perldb, getpid());
	sv_setiv(PL_DBsingle, 1);
	/* PL_perldb = 0x0103; */
	XSRETURN_IV(prev_DBsingle);

void
disable_profile(...)
    PPCODE:
	IV prev_DBsingle = SvIV(PL_DBsingle);
	warn("disable_profile (was %d, perldb %x) in pid %d", prev_DBsingle, PL_perldb, getpid());
	sv_setiv(PL_DBsingle, 0);
	/* PL_perldb = 0; */
	XSRETURN_IV(prev_DBsingle);

MODULE = Devel::FastProf		PACKAGE = Devel::FastProf::Reader

void _read_file(char *infn)
PPCODE:
    {
        HV *ticks = get_hv("Devel::FastProf::Reader::TICKS", TRUE);
        HV *count = get_hv("Devel::FastProf::Reader::COUNT", TRUE);
        AV *fn = get_av("Devel::FastProf::Reader::FN", TRUE);
        AV *src = get_av("Devel::FastProf::Reader::SRC", TRUE);
        HV *fpidmap = get_hv("Devel::FastProf::Reader::FPIDMAP", TRUE);
        HV *ppid = get_hv("Devel::FastProf::Reader::PPID", TRUE);
        float inv_ticks_per_second = 1.0;
        IV lfid = 0, nfid = 0, lline;
        int not_first = 0;
        IV pid = 0;
        SV *key = sv_2mortal(newSV(30));
        char *k;
        STRLEN l;
        SV **ent;
        char head[12];
        HV *pidlfid = (HV*)sv_2mortal((SV*)newHV());
        HV *pidlline = (HV*)sv_2mortal((SV*)newHV());

        FILE *in = fopen(infn, "rb");
        if (!in) Perl_croak(aTHX_ "unable to open %s for reading", infn);

        if ((fread(head, 1, 12, in) != 12) || strncmp(head, "D::FP-" XS_VERSION, 12))
            Perl_croak(aTHX_ "bad header, input file has not been generated by Devel::FastProf " XS_VERSION);

        while (fneof(in)) {
            IV mark = fgetmark(aTHX_ in);
            switch (mark) {
            case 0: /* line execution timestamp */
            {
                IV line = fgetiv(aTHX_ in);
                IV delta = fgetiv(aTHX_ in);
                /* fprintf(stderr, "fid: %d, line: %d, delta: %d\n", fid, line, delta); */
                if (not_first) {
                    SV **tsv, **csv;
                    /* SV *key = newSVpvf("%d:%d", lfid, lline); */
                    sv_setpvf(key, "%d:%d", lfid, lline);
                    k = SvPV(key, l);
                    tsv = hv_fetch(ticks, k, l, TRUE);
                    csv = hv_fetch(count, k, l, TRUE);
                    if (tsv && csv) {
                        float old = SvOK(*tsv) ? SvNV(*tsv) : 0.0;
                        /* printf("delta: %d\n", delta); */
                        sv_setnv(*tsv, old + delta * inv_ticks_per_second);
                        sv_inc(*csv);
                    }
                    else {
                        Perl_croak(aTHX_ "internal error");
                    }
                }
                else {
                    not_first = 1;
                }
                lfid = nfid;
                lline = line;
                break;
            }
            case 1: /* filename comming */
            {
                IV fid = pid ? mapid(aTHX_ fpidmap, pid, fgetiv(aTHX_ in)) : fgetiv(aTHX_ in);
                SV *fsv = fgetpv(aTHX_ in);
                av_store(fn, fid, fsv);
                break;
            }
            case 2: /* src comming */
            {
                IV fid = pid ? mapid(aTHX_ fpidmap, pid, fgetiv(aTHX_ in)) : fgetiv(aTHX_ in);
                AV *lines = fgetav(aTHX_ in);
                SV *ref = newRV_noinc((SV*)lines);
                av_store(src, fid, ref);
                break;
            }
            case 3: /* ticks per second */
            {
                IV tps = fgetiv(aTHX_ in);
                if (!tps)
                    Perl_croak(aTHX_ "bad parameter value: ticks_per_second = 0");
                
                inv_ticks_per_second = 1.0 / tps;
                break;
            }
            case 4:
            {
                Perl_croak(aTHX_ "obsolete file format");
            }
            case 5:
            {
                if (not_first) {
                    sv_setiv(key, pid);
                    k = SvPV(key, l);
                    ent = hv_fetch(pidlfid, k, l, TRUE);
                    sv_setiv(*ent, lfid);
                    ent = hv_fetch(pidlline, k, l, TRUE);
                    sv_setiv(*ent, lline);
                }            
                pid = fgetiv(aTHX_ in);
                sv_setiv(key, pid);
                k = SvPV(key, l);
                ent = hv_fetch(pidlfid, k, l, 0);
                if (ent) {
                    not_first = 1;
                    lfid = SvIV(*ent);
                    ent = hv_fetch(pidlline, k, l, TRUE);
                    lline = SvIV(*ent);
                }
                else {
                    not_first = 0;
                }
                break;
            }
            case 6:
            {
                sv_setiv(key, pid);
                k = SvPV(key, l);
                ent = hv_fetch(ppid, k, l, TRUE);
                sv_setiv(*ent, fgetiv(aTHX_ in));
                break;
            }
            case 7:
            {
                IV fid = fgetiv(aTHX_ in);
                nfid = pid ? mapid(aTHX_ fpidmap, pid, fid) : fid;
                /* fprintf(stderr, "lfid: %d\n", nfid); fflush(stderr); */
                
                break;
            }
            default:
                Perl_croak(aTHX_ "bad file format");
            }
        }
    }
